perm filename VIOLA[1,LMM] blob
sn#033089 filedate 1973-04-03 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00012 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00002 00002 OPEN (CP SYSFILE INPUT)
C00020 00003 ELSE (APPEND1 X (CAR L))
C00037 00004 PLUS 1)
C00051 00005 DEFINE ((
C00067 00006 LABELED
C00082 00007 (EQ (IDMULT X) @ MULT)))
C00084 00008 DEFINE ((
C00098 00009 XLIST (INSERTMARKERS
C00099 00010 (LABELED L)))))
C00106 00011 ADVISE (((CATALOG3 BEFORE (IF (EQUAL ARG1 @ (0 3)) THEN (RETURN (LIST
C00116 00012 (REPLACE (LASTNODE# STRUC) (LASTNODE# B))
C00124 ENDMK
C⊗;
OPEN (CP SYSFILE INPUT)
RESTORE (CP)
CLOSE (CP)
FIXDEFINE ((COMPILE MACRO PRINT))
CLEANUP (ARRAY)
(LAMBDA NIL
(BPSMOVE (DIFFERENCE (BPSLEFT) 12000))) NIL
RECORD (SUPERATOMPARTITION (SUPERATOMPARTS . REMAININGATOMS))
RECORD (FVPARTITION (NEWVL . FVR))
RECORD (STRUCFORM (ID$ . FORM))
RECORD (STRUCTURE (ID1 CTABLE UGRAPH LASTNODE# . GROUP))
RECORD (RADICAL (CENTER . ATTACHEDRADS))
RECORD (MAKECENTER (AFFLINK RADSTRUC . CUFFLINKS))
RECORD (IDDUMMY (ID . RESTOF-IDDUMMY))
RECORD (MARKER-REC (ATOMTYPE . OTHERMARKERS))
RECORD (CTENTRY (ID2 NODENUM MARKERS . NBRS))
RECORD (EDGE (NODE1 . NODE2))
RECORD (LOOPPARTITION (LOOPVL EDGELABELS . LOOPLABELS))
DEFAULT (STRUCFORM (ID$ FORM))
DEFAULT (STRUCTURE (GROUP (NIL)))
DEFAULT (STRUCTURE (ID1 STRUC))
DEFAULT (CTENTRY (MARKERS (NIL)))
DEFAULT (CTENTRY (ID2 CTE))
SPECIAL ((LASTNODE TRIVALENTCODES))
SPECIAL ((CATALOG-LIST))
SPECIAL ((XLATETABLE XLATN))
GSET (GRAPHFILE LISPOUT)
DEFINE ((
(NUMPARTITIONS (LAMBDA (N NUMPARTS MINPART MAXPART)
(IF (EQUAL NUMPARTS 1)
THEN (IF (OR (GREATERP MINPART N) (LESSP MAXPART N))
THEN NIL
ELSE (LIST (LIST N)))
ELSE (FOR NEW I
:= ((MAX
MINPART
(DIFFERENCE
N
(TIMES (SUB1 NUMPARTS) MAXPART)))
(MIN MAXPART (QUOTIENT N NUMPARTS)))
FOR NEW RESTPART
IN (NUMPARTITIONS
(DIFFERENCE N I)
(SUB1 NUMPARTS)
I
MAXPART) LIST (CONS I RESTPART)))))
))
DEFINE ((
(CLPARTITIONS (LAMBDA (CL PARTSIZES)
(IF (NULL PARTSIZES) THEN (LIST NIL)
ELSEIF (NULL (CDR PARTSIZES)) THEN (LIST (LIST CL))
ELSEIF (ZEROP (CAR PARTSIZES))
THEN (MAPCAR
(CLPARTITIONS CL (CDR PARTSIZES))
(FUNCTION (LAMBDA (X)
(CONS NIL X))))
ELSEIF (EQUAL (CAR PARTSIZES) (CADR PARTSIZES))
THEN (PROG (N THISPART)
(SETQ N 1)
(SETQ THISPART (CAR PARTSIZES))
(FOR PARTSIZES ON (CDR PARTSIZES)
WHILE (EQUAL (CAR PARTSIZES) THISPART)
DO (SETQ N (ADD1 N)))
(IF (NULL PARTSIZES)
THEN (RETURN (CL=PARTS CL N THISPART)))
(RETURN (FOR NEW BIGPART
IN (CLPARTS CL (TIMES N THISPART))
AS NEW RESTPARTSLIST
IS (CLPARTITIONS
(CLDIFF CL BIGPART)
PARTSIZES)
FOR NEW LITTLEPARTS
IN (CL=PARTS BIGPART N THISPART)
FOR NEW RESTPARTS
IN RESTPARTSLIST
XLIST (APPEND
LITTLEPARTS
RESTPARTS))))
ELSE (FOR NEW PART IN (CLPARTS CL (CAR PARTSIZES))
FOR NEW PARTS
IN (CLPARTITIONS
(CLDIFF CL PART)
(CDR PARTSIZES)) XLIST (CONS PART PARTS)))))
))
DEFINE ((
(CLPARTS (LAMBDA (CL PARTSIZE)
(IF (ZEROP PARTSIZE) THEN (LIST NIL)
ELSEIF (NULL (CDR CL))
THEN (LIST (LIST (CONS (CAAR CL) PARTSIZE)))
ELSE (PROG (SIZE)
(SETQ SIZE
(DIFFERENCE PARTSIZE (CLCOUNT (CDR CL))))
(RETURN (FOR NEW X
:= ((MAX SIZE 1) (MIN PARTSIZE (CDAR CL)))
FOR NEW PART
IN (CLPARTS
(CDR CL)
(DIFFERENCE PARTSIZE X))
XLIST
FIRST (IF (LESSP 0 SIZE) THEN NIL
ELSE (CLPARTS (CDR CL) PARTSIZE))
(CONS (CONS (CAAR CL) X) PART)))))))
))
DEFINE ((
(CL=PARTS (LAMBDA (CL NPARTS PARTSIZE)
(IF (NULL (CDR CL))
THEN (SETQ CL (LIST (CONS (CAAR CL) PARTSIZE)))
(LIST (FOR NEW I := (1 NPARTS) XLIST CL))
ELSE (FOR NEW X
IN (NUMPARTITIONS (CDAR CL) NPARTS 0 PARTSIZE)
FOR NEW Y
IN (CLPARTITIONS
(CDR CL)
(FOR NEW XX IN X
LIST (DIFFERENCE PARTSIZE XX)))
XLIST (FOR NEW XX IN X AS NEW YY IN Y
LIST (IF (ZEROP XX) THEN YY
ELSE (CONS (CONS (CAAR CL) XX) YY)))))))
))
DEFINE ((
(CLDIFF (LAMBDA (CL1 CL2)
(IF (NULL CL2) THEN CL1
ELSEIF (EQUAL (CAR CL1) (CAR CL2))
THEN (CLDIFF (CDR CL1) (CDR CL2))
ELSEIF (EQ (CAAR CL1) (CAAR CL2))
THEN (CONS
(CONS
(CAAR CL1)
(DIFFERENCE (CDAR CL1) (CDAR CL2)))
(CLDIFF (CDR CL1) (CDR CL2)))
ELSE (CONS (CAR CL1) (CLDIFF (CDR CL1) CL2)))))
))
DEFINE ((
(CLCOUNT (LAMBDA (CL)
(FOR NEW X IN CL PLUS (CDR X))))
))
DEFINE ((
(CLPARTITIONSN (LAMBDA (CL N MINPARTSIZE MAXPARTSIZE)
(FOR NEW PARTSIZES
IN (NUMPARTITIONS (CLCOUNT CL) N MINPARTSIZE MAXPARTSIZE)
NCONC FIRST NIL
(CLPARTITIONS CL PARTSIZES))))
))
DEFINE ((
(CLCREATE (LAMBDA (L)
(PROG (CL)
(FOR NEW X IN L DO (SETQ CL (CLINSERT X CL)))
(RETURN CL))))
))
DEFINE ((
(CLINSERT (LAMBDA (ITEM CL)
(IF (NOT CL) THEN (LIST (CONS ITEM 1))
ELSEIF (EQUAL ITEM (CAAR CL))
THEN (REPLACE (CDR (CAR CL)) (ADD1 (CDR (CAR CL))))
CL
ELSEIF (LEQ ITEM (CAAR CL)) THEN (CONS (CONS ITEM 1) CL)
ELSE (REPLACE (CDR CL) (CLINSERT ITEM (CDR CL))))))
))
DEFINE ((
(GENRAD (LAMBDA (CL)
(IF (AND (NULL (CDR CL)) (EQUAL (CDAR CL) 1))
THEN (PERMRADS (CAAR CL) NIL T)
ELSE (FOR NEW OLDCL ON CL AS NEW CENTER IS (CAAR OLDCL)
AS NEW NEWCL
IS (CLDIFF CL (LIST (CONS CENTER 1)))
FOR NEW DEGREE
:= (1 (MIN
(CLCOUNT NEWCL)
(SUB1 (VALENCE CENTER))))
FOR NEW RADS IN (GENRADS NEWCL DEGREE)
NCONC FIRST NIL
(PERMRADS CENTER RADS T)))))
))
DEFINE ((
(GENRADS (LAMBDA (CL N)
(IF (NULL CL) THEN (LIST NIL)
ELSE (FOR NEW PARTITION
IN (CLPARTITIONSN CL N 1 (CLCOUNT CL))
NCONC FIRST NIL
(GENRADLIST PARTITION)))))
))
DEFINE ((
(GENRADLIST (LAMBDA (CLLIST)
(GROUPRADS (GENRADLIST1 (CLCREATE CLLIST)))))
))
DEFINE ((
(GENRADLIST1 (LAMBDA (CLCL)
(FOR NEW CLNUMPAIR IN CLCL
LIST (CONS (GENRAD (CAR CLNUMPAIR)) (CDR CLNUMPAIR)))))
))
DEFINE ((
(GROUPRADS (LAMBDA (RADCLIST)
(IF (NULL RADCLIST) THEN (LIST NIL)
ELSE (GROUPRADS1
(CAAR RADCLIST)
(CDAR RADCLIST)
(GROUPRADS (CDR RADCLIST))))))
))
DEFINE ((
(GROUPRADS1 (LAMBDA (RADLIST N RADSLIST)
(IF (ZEROP N) THEN RADSLIST
ELSE (FOR RADLIST ON RADLIST
FOR NEW RADS
IN (GROUPRADS1 RADLIST (SUB1 N) RADSLIST)
LIST (CONS (CAR RADLIST) RADS)))))
))
DEFINE ((
(VALENCE (LAMBDA (AT)
(COND
((NUMBERP AT) AT)
((ATOM AT) (GET AT @ VALENCE))
(T (FREEVALENCESIZE AT)))))
))
DEFINE ((
(GENMOL (LAMBDA (CL)
(PROG (MINDEG RESULT NATOMS)
(IF (EQUAL 1 (SETQ NATOMS (CLCOUNT CL)))
THEN (RETURN (PERMRADS (CAAR CL) NIL NIL))
ELSEIF (EVENP NATOMS)
THEN (FOR NEW PART
IN (CL=PARTS CL 2 (QUOTIENT NATOMS 2))
FOR NEW RADS IN (GENRADLIST PART)
DO (SETQ RESULT
(APPEND
(PERMRADS NIL RADS NIL)
RESULT)))
(SETQ MINDEG 3)
ELSE (SETQ MINDEG 2))
(SETQ NATOMS (SUB1 NATOMS))
(FOR NEW PAIR IN CL AS NEW CENTER IS (CAR PAIR)
AS NEW NEWCL IS (CLDIFF CL (LIST (CONS CENTER 1)))
FOR NEW DEG
:= (MINDEG (MIN (VALENCE CENTER) NATOMS))
FOR NEW P
IN (CLPARTITIONSN
NEWCL
DEG
1
(QUOTIENT NATOMS 2))
FOR NEW RADS IN (GENRADLIST P)
DO (SETQ RESULT
(NCONC
(PERMRADS CENTER RADS NIL)
RESULT)))
(RETURN RESULT))))
))
DEFINE ((
(FIX+ (LAMBDA (X)
(FIX (PLUS X 0.99))))
))
DEFINE ((
(NUMPARTITIONS* (LAMBDA (U MN MAXIMA OCCURLIST)
(IF (NULL (CDR OCCURLIST))
THEN (NUMPARTITIONS U (CAR OCCURLIST) MN (CAR MAXIMA))
ELSE (FOR NEW FIRST
:= ((FIX+ (MAX
MN
(DIFFERENCE
U
(FOR NEW X IN (CDR MAXIMA)
AS NEW Y IN (CDR OCCURLIST)
PLUS
FIRST (TIMES
(SUB1 (CAR OCCURLIST))
(CAR MAXIMA))
(TIMES X Y)))))
(MIN
(CAR MAXIMA)
(QUOTIENT
(DIFFERENCE U (*PLUS (CDR OCCURLIST)))
(CAR OCCURLIST))))
FOR NEW REST
IN (IF (EQUAL (CAR OCCURLIST) 1)
THEN (NUMPARTITIONS*
(DIFFERENCE U FIRST)
1
(CDR MAXIMA)
(CDR OCCURLIST))
ELSE (NUMPARTITIONS*
(DIFFERENCE U FIRST)
FIRST
MAXIMA
(CONS
(SUB1 (CAR OCCURLIST))
(CDR OCCURLIST))))
XLIST (CONS FIRST REST)))))
))
DEFINE ((
(GROUPBY (LAMBDA (FN L)
(IF (NULL L) THEN NIL
ELSE (PROG (FNX GROUPCDR X)
(SETQ GROUPCDR (GROUPBY FN (CDR L)))
(IF (NULL (SETQ X
(ASSOC (SETQ FNX (FN (CAR L))) GROUPCDR NIL)))
THEN (RETURN (CONS
(LIST FNX (CAR L))
GROUPCDR))
ELSE (APPEND1 X (CAR L))
(RETURN GROUPCDR))))))
))
DEFINE ((
(FVPARTITION1 (LAMBDA (N VL S)
(COND
((NULL VL) (LIST NIL))
(T (PROG (SUMREST)
(SETQ SUMREST
(FOR NEW X IN (CDR VL)
AS NEW SP := ((ADD1 S) 9999999)
PLUS (TIMES SP X)))
(RETURN (FOR NEW I
:= ((MAX 0 (DIFFERENCE N SUMREST))
(MIN N (TIMES (CAR VL) S)))
AS NEW PARTREST
IS (FVPARTITION1
(DIFFERENCE N I)
(CDR VL)
(ADD1 S))
FOR NEW FIRSTPART IN (FVPART1 I (CAR VL) S)
FOR NEW RESTPART IN PARTREST
XLIST (CONS FIRSTPART RESTPART))))))))
))
DEFINE ((
(FVPART1 (LAMBDA (N MAXSUM MAXOCCUR)
(COND
((ZEROP MAXOCCUR) (LIST NIL))
(T (FOR NEW I
:= ((MAX
0
(DIFFERENCE N (TIMES MAXSUM (SUB1 MAXOCCUR)))
(COMMENT I*MAXOCCUR + (MAXSUM-I) * (MAXOCCUR-1)
>=N I*MAXOCCUR+MAXSUM* (MAXOCCCUR-1) -I* (MXO-1)
OR I>=N-MAXSUM* (MAXOCCUR-1)))
(MIN MAXSUM (QUOTIENT N MAXOCCUR)))
FOR NEW REST
IN (FVPART1
(DIFFERENCE N (TIMES I MAXOCCUR))
(DIFFERENCE MAXSUM I)
(SUB1 MAXOCCUR)) XLIST (CONS I REST))))))
))
DEFINE ((
(MINLOOPS (LAMBDA (VALENCELIST)
(MAX
0
(PROG (MXV TD)
(* SETQ TD MXV 0)
(FOR NEW X IN (CDR VALENCELIST)
AS NEW VALENCE := (3 999999)
WHEN
(NOT (ZEROP X))
DO (IF (GREATERP VALENCE MXV)
THEN (SETQ MXV VALENCE))
(SETQ TD (PLUS (TIMES X VALENCE) TD)))
(RETURN (QUOTIENT (DIFFERENCE MXV TD) 2))))))
))
DEFINE ((
(MAXLOOPS (LAMBDA (VALENCELIST)
(MIN
(CAR VALENCELIST)
(FIX+ (FOR NEW W IN (CDDR VALENCELIST)
AS NEW J := (2 99999) PLUS (TIMES 0.5 W J))))))
))
DEFINE ((
(MOLECULES (LAMBDA (CL U)
(IF (ZEROP U) THEN (GENMOL CL)
ELSE (FOR NEW SAP IN (SUPERATOMPARTITIONS CL U)
FOR NEW S IN (SUPERATOMS (SUPERATOMPARTS SAP))
NCONC FIRST NIL
(GENMOL (APPEND
(CLCREATE S)
(REMAININGATOMS SAP)))))))
))
DEFINE ((
(SUPERATOMPARTITIONS (LAMBDA (CL U)
(PROG (CL1 SZ)
(SETQ CL1
(FOR NEW PR IN CL
WHEN
(EQUAL (VALENCE (CAR PR)) 1)
LIST PR))
(SETQ CL (CLDIFF CL CL1))
(RETURN (FOR NEW PARTSIZE
:= (2 (SETQ SZ (CLCOUNT CL)))
FOR NEW VHAT IN (CLPARTS CL PARTSIZE)
AS NEW REMATS IS (APPEND CL1 (CLDIFF CL VHAT))
FOR NEW #PARTS := (1 (QUOTIENT PARTSIZE 2))
FOR NEW PARTITION
IN (CLPARTITIONSN VHAT #PARTS 2 9999999)
AS NEW VI IS (CLCREATE PARTITION)
AS NEW MXUI IS (MAXUNSATL VI)
WHEN
MXUI FOR NEW UI IN
(NUMPARTITIONS*
U
1
MXUI
(MAPCAR VI @ CDR))
XLIST (SUPERATOMPARTITION
REMAININGATOMS
=
REMATS
SUPERATOMPARTS
=
(PROG (CVI CVN M VI2 CUI VI3)
(SETQ VI3 VI)
VILOOP(IF (NULL VI3)
THEN (RETURN VI2))
(SETQ CVI (CAAR VI3))
(SETQ CVN (CDAR VI3))
(SETQ VI3 (CDR VI3))
LOOPM (SETQ M 0)
LOOPCVN
(SETQ M (ADD1 M))
(SETQ CVN (SUB1 CVN))
(SETQ CUI (CAR UI))
(SETQ UI (CDR UI))
(IF (AND
(NOT (ZEROP CVN))
(EQUAL CUI (CAR UI)))
THEN (GO LOOPCVN))
(SETQ VI2
(CONS
(CONS (CONS CUI CVI) M)
VI2))
(IF (ZEROP CVN)
THEN (GO VILOOP)
ELSE (GO LOOPM)))))))))
))
DEFINE ((
(MAXUNSATL (LAMBDA (PC)
(FOR NEW PART-NUM IN PC
LIST (PROG (N TD M)
(* SETQ N TD M 0)
(FOR NEW PR IN (CAR PART-NUM)
DO
(SETQ N (PLUS N (CDR PR)))
(SETQ TD
(PLUS TD (TIMES (CDR PR) (VALENCE (CAR PR)))))
(SETQ M (MAX M (VALENCE (CAR PR)))))
(RETURN (FIX (TIMES
0.5
(PLUS
2
TD
(TIMES -2 N)
(MIN -1 (DIFFERENCE TD (TWICE M)))))))))))
))
DEFINE ((
(SUPERATOMS (LAMBDA (UCL-COMP)
(GROUPRADS (FOR NEW UCLN IN UCL-COMP
LIST (CONS (RINGS (CAAR UCLN) (CDAR UCLN)) (CDR UCLN))))))
))
DEFINE ((
(COMPUTEFV (LAMBDA (U CL)
(PROG (TD N)
(* SETQ TD N 0)
(FOR NEW PR IN CL
DO
(SETQ TD
(PLUS (TIMES (VALENCE (CAR PR)) (CDR PR)) TD))
(SETQ N (PLUS (CDR PR) N)))
(RETURN (PLUS 2 TD (TIMES -2 (PLUS N U)))))))
))
DEFINE ((
(CLBYVALENCE (LAMBDA (CL)
(PROG2
(SETQ CL
(GROUPBY
(FUNCTION (LAMBDA (PR)
(VALENCE (CAR PR))))
CL))
(FOR NEW I := (2 (*MAX (MAPCAR CL @ CAR)))
LIST (ASSOC I CL NIL)))))
))
DEFINE ((
(RINGS (LAMBDA (U CL)
(PROG (FV)
(SETQ FV (COMPUTEFV U CL))
(SETQ CL (CLBYVALENCE CL))
(RETURN (FOR NEW SKELETON
IN (RINGSKELETONS FV (MAPCAR CL @ CLCOUNT))
NCONC FIRST NIL
(STRUCTURESWITHATOMS CL SKELETON))))))
))
DEFINE ((
(FVPARTITIONS (LAMBDA (FV VL)
(FOR NEW FVP IN (FVPARTITION1 FV (CDR VL) 1)
AS NEW FVR IS (ROWS FVP)
XLIST (FVPARTITION
FVR
=
FVR
NEWVL
=
(FOR NEW ROW IN FVR AS NEW COL IN (CONS NIL FVP)
AS NEW V IN VL
LIST (PLUS V (*PLUS ROW) (MINUS (*PLUS COL))))))
))
))
DEFINE ((
(RINGSKELETONS (LAMBDA (FV VL)
(FOR NEW FVPART IN (FVPARTITIONS FV VL)
FOR NEW STRUC IN (NOFV-RINGS (NEWVL FVPART))
NCONC FIRST NIL
(ATTACHFVS (FVR FVPART) STRUC))))
))
DEFINE ((
(NOFV-RINGS (LAMBDA (VL)
(PROG (MNLPS MXLPS SUMREST)
(SETQ SUMREST (*PLUS (CDR VL)))
(IF (ZEROP SUMREST)
THEN (RETURN (SINGLERINGS (CAR VL)))
ELSEIF (EQUAL SUMREST 1) THEN (RETURN (DAISIES VL)))
(SETQ MNLPS (MINLOOPS VL))
(SETQ MXLPS (MAXLOOPS VL))
(RETURN (FOR NEW P := (MNLPS MXLPS)
NCONC FIRST NIL
(KLOOPEDRINGS P VL))))))
))
DEFINE ((
(DAISIES (LAMBDA (VL)
(FOR NEW P
IN (NUMPARTITIONS
(CAR VL)
(QUOTIENT
(FOR NEW X IN (CDR VL) AS NEW I := (3 99999)
UNTIL (NOT (ZEROP X)) PROG2 I)
2)
1
99999999) NCONC FIRST NIL
(DAISY (CLCREATE P)))))
))
DEFINE ((
(NOLOOPEDRINGS (LAMBDA (VL)
(IF (ZEROP (CAR VL)) THEN (CATALOG (CDR VL))
ELSE (PROG (BP)
(SETQ BP (BIVALENTPARTITIONS VL))
(RETURN (FOR NEW S IN (CATALOG (CDR VL))
FOR NEW P IN BP
NCONC FIRST NIL
(ATTACHBIVALENTS (CLCREATE P) S)))))))
))
DEFINE ((
(TWICE (LAMBDA (X)
(PLUS X X)))
))
DEFINE ((
(ROWS (LAMBDA (LL)
(IF (NOT LL) THEN @
(NIL)
ELSE (CONS
(MAPCAR LL @ CAR)
(ROWS (MAPCAR (CDR LL) @ CDR))))))
))
DEFINE ((
(BIVALENTPARTITIONS (LAMBDA (VL)
(NUMPARTITIONS
(CAR VL)
(QUOTIENT
(FOR NEW I := (3 9999) AS NEW X IN (CDR VL)
PLUS (TIMES I X))
2)
0
(CAR VL))))
))
DEFINE ((
(ISOMERS (LAMBDA (U CL)
(FOR NEW X IN (MOLECULES CL U) AS NEW I := (1 99999)
DO
(TTAB 1)
(PRIN1 I)
(PRIN1 PERIOD)
(TTAB 5)
(PRINRAD X)
(TERPRI))))
))
DEFLIST ((
(C 4)
(N 3) (I 1) (CL 1) (BR 1) (F 1) (S 2) (P 5)
(O 2) (SI 4)
(H 1)) VALENCE)
MACRO ((
(STRUCTURE? (LAMBDA (X)
(EQ (ID X) @ STRUC)))
))
MACRO ((
(STRUCFORM? (LAMBDA (X)
(EQ (ID X) @ FORM)))
))
DEFINE ((
(FREEVALENCESIZE (LAMBDA (S)
(IF (STRUCTURE? S)
THEN (FOR NEW X IN (CTABLE S) FOR NEW Y IN (NBRS X)
WHEN
(EQ Y @ FV)
PLUS 1)
ELSEIF (STRUCFORM? S)
THEN (IF (EQ (CAR (FORM S)) @ ATTACHFVS)
THEN (FOR NEW FVL IN (CADR (FORM S))
FOR NEW X IN FVL AS NEW I := (1 999999)
PLUS (TIMES I X))
ELSE (FREEVALENCESIZE (CADDR (FORM S)))))))
))
DEFINE ((
(NODES (LAMBDA (STRUC)
(MAPCAR (CTABLE STRUC) (FUNCTION (LAMBDA (X)
(NODENUM X))))))
))
DEFINE ((
(COLLECTFV (LAMBDA (S)
(FOR NEW CT IN (CTABLE S) FOR NEW X IN (NBRS CT)
WHEN
(EQ X @ FV)
XLIST (NODENUM CT))))
))
DEFINE ((
(TRIMZEROS (LAMBDA (L)
(PROG (N)
(RETURN (IF (NULL L) THEN NIL
ELSEIF (ZEROP (SETQ N (*PLUS L))) THEN NIL
ELSE (CONS (CAR L) (TRIMZEROS (CDR L))))))))
))
DEFINE ((
(CATALOG (LAMBDA (L)
(IF (AND
(EQUAL (*PLUS (SETQ L (TRIMZEROS L))) 2)
(EQUAL (CAR (LAST L)) 2))
THEN (LIST (STRUCWITH2NODES (PLUS 2 (LENGTH L))))
ELSE (CATALOG3 L))))
))
DEFINE ((
(STRUCWITH2NODES (LAMBDA (N)
(STRUCTURE
(CONS @ MBONDS N)
CTABLE
=
(LIST
(CTENTRY
NODENUM
=
1
NBRS
=
(FOR NEW I := (1 N) XLIST 2))
(CTENTRY
NODENUM
=
2
NBRS
=
(FOR NEW I := (1 N) XLIST 1)))
LASTNODE#
=
2)))
))
DEFINE ((
(CATALOG3 (LAMBDA (TVL)
(PROG (C)
(COND
((NOT (ZEROP (*PLUS (CDR TVL)))) NIL)
(T (SETQ C (NTH CATALOG-LIST (QUOTIENT (CAR TVL) 2)))))
(RETURN (IF (AND C (CAR C)) THEN (CAR C)
ELSE (LIST (STRUCFORM FORM=(CONS @ CATALOG TVL))))))))
))
DEFINE ((
(DAISY (LAMBDA (PART)
(PROG (S C)
(SETQ LASTNODE 1)
(SETQ S
(STRUCTURE
UGRAPH=
(CONS @ DAISY PART)
CTABLE
=
(LIST (CTENTRY NODENUM = LASTNODE))
LASTNODE#
=
LASTNODE))
(SETQ C LASTNODE)
(RETURN (LIST (FOR NEW PAIR IN PART
FOR NEW I := (1 (CDR PAIR))
PROG2 (SETQ S (PUTBIVN S C (CAR PAIR)))))))))
))
DEFINE ((
(MAKECAT (LAMBDA (TVC)
(FOR NEW X IN TVC AS NEW J IS (CAR X)
LIST (FOR NEW Y IN (CDR X) LIST (TRIVGRAPH J Y)))))
))
DEFINE ((
(TRIVGRAPH (LAMBDA (J L)
(PROG (S X Y LL N)
(SETQ LL L)
(SETQ S (SINGLERING J))
(SETQ X (FOR NEW I := (J 1 -1) XLIST I))
(FOR X ON X AS L ON L
DO
(SETQ N (PLUS (CHORDLENGTH (CAR L)) (CAR X)))
(CONNECT (FINDCTE (CAR X) S) (FINDCTE N S) S)
(SETQ X (DELETE N X)))
(RETURN (STRUCTURE FROM S UGRAPH = (CONS J LL))))))
))
DEFINE ((
(CHORDLENGTH (LAMBDA (X)
(CDR (SASSOC
X
@ ((A . 1) (B . 2) (C . 3) (D . 4) (E . 5) (F . 6) (G . 7)
(H . 8) (I . 9))
NIL))))
))
GSET (TRIVALENTCODES ((2 (A)) (4 (B B) (A A)) (6 (B C B) (A A A) (A
B B) (A C A) (C C C)) (8 (B C C B) (B D D B) (C E C C) (A A A A)
(A A B B) (A A C A) (A B C B) (A B D A) (A C D B) (A D D A) (A E
B B) (A E C A) (B B B B))))
DEFINE ((
(SINGLERING (LAMBDA (N)
(PROG (S)
(SETQ LASTNODE 0)
(SETQ S (BIVCHAIN N))
(CONNECT
(FINDCTE (FIRSTOFNODES S) S)
(FINDCTE (LASTOFNODES S) S))
(RETURN (STRUCTURE
FROM
S
UGRAPH
=
(CONS @ SINGLERING N))))))
))
COMMENT (ROUTINES FOR MANIPULATING STRUCTURE)
DEFINE ((
(BIVCHAIN (LAMBDA (N)
(FOR NEW I := (1 N) AS NEW X IS X
PROG2 (SETQ X (PUTNEWNODE X)))))
))
DEFINE ((
(CONNECT (LAMBDA (X Y)
(PROG NIL
(REPLACE (NBRS X) (CONS (NODENUM Y) (NBRS X)))
(COND
((NOT (EQ X Y))
(REPLACE (NBRS Y) (CONS (NODENUM X) (NBRS Y))))))))
))
DEFINE ((
(COPYSTRUC (LAMBDA (S)
(PROG2 (SETQ LASTNODE (LASTNODE# S)) (COPY S))))
))
DEFINE ((
(DISCONNECT (LAMBDA (X Y)
(PROG NIL
(REPLACE (NBRS X) (DELETE (NODENUM Y) (NBRS X)))
(REPLACE (NBRS Y) (DELETE (NODENUM X) (NBRS Y))))))
))
DEFINE ((
(FINDCTE (LAMBDA (N LST)
(IF (NUMBERP N)
THEN (IF (EQ (ID LST) @ STRUC)
THEN (SETQ LST (CTABLE LST))
ELSE NIL)
(FOR NEW L IN LST
WHEN
(EQUAL (NODENUM L) N)
DO (RETURN L))
ELSEIF (NUMBERP LST) THEN (FINDCTE LST N)
ELSE (ERROR @ (BAD ARGUMENTS TO FINDCTE)))))
))
DEFINE ((
(FIRSTOFNODES (LAMBDA (X)
(CAR (NODES X))))
(LASTOFNODES (LAMBDA (X)
(CAR (LAST (NODES X)))))
))
DEFINE ((
(LISTBYVALENCE (LAMBDA (S)
(PROG (M V)
(SETQ M (LENGTH (NODES S)))
(RETURN (FOR NEW I := (2 999) WHILE (GREATERP M 0)
LIST
(SETQ V (VALENCETYPE S I))
(SETQ M (DIFFERENCE M (LENGTH V)))
V)))))
))
DEFINE ((
(PUTFVN (LAMBDA (S N J)
(PROG NIL
(SETQ N (FINDCTE N (CTABLE S)))
(REPLACE
(NBRS N)
(NCONC (NBRS N) (FOR NEW I := (1 J) XLINBRS N) (FOR NEW I := (1 J) XLIST
@ FV)))
(RETURN S))))
))
DEFINE ((
(PUTFVS (LAMBDA (S FVP)
(FOR NEW NI IN FVP FOR NEW NIJ IN NI AS NEW J := (1 10)
FOR NEW NODE IN NIJ PROG2 (SETQ S (PUTFVN S NODE J)))))
))
DEFINE ((
(PUTNEWNODE (LAMBDA (STRUC)
(IF STRUC
THEN (PROG2
(SETQ LASTNODE (ADD1 (LASTNODE# STRUC)))
(STRUCTURE
FROM
STRUC
CTABLE
=
(PUTNEWNODEINCT
(CTENTRY NODENUM = LASTNODE)
(CTABLE OF STRUC))
LASTNODE#
=
LASTNODE))
ELSE (PROG2
(SETQ LASTNODE (ADD1 LASTNODE))
(STRUCTURE
CTABLE
=
(LIST (CTENTRY NODENUM = LASTNODE))
LASTNODE#
=
LASTNODE)))))
))
DEFINE ((
(PUTNEWNODEINCT (LAMBDA (X Y)
(PROG (Z)
(SETQ Z (CAR Y))
(REPLACE (NBRS OF Z) (CONS (NODENUM X) (NBRS Z)))
(REPLACE (NBRS OF X) (CONS (NODENUM Z) (NBRS X)))
(RETURN (CONS X Y)))))
))
DEFINE ((
(NODEVALENCE (LAMBDA (NODE)
(IF (NULL NODE)
THEN (ERROR @ (NULL NODE GIVEN TO NODEVALENCE))
ELSEIF (EQ (ID NODE) @ CTE) THEN (LENGTH (NBRS NODE))
ELSE (NODEVALENCE (FINDCTE (CAR NODE) (CDR NODE))))))
))
DEFINE ((
(VALENCETYPE (LAMBDA (S I)
(FOR NEW NODE IN (CTABLE S)
WHEN
(EQUAL I (NODEVALENCE NODE))
XLIST (NODENUM NODE))))
))
COMMENT (GENERAL LISP ROUTINES)
DEFINE ((
(CARLIST (LAMBDA (L)
(FOR NEW X IN L LIST (CAR X))))
(CDRLIST (LAMBDA (L)
(FOR NEW X IN L LIST (CDR X))))
(LCARLIST (LAMBDA (L)
(FOR NEW X IN L LIST (CARLIST X))))
(LCDRLIST (LAMBDA (L)
(FOR NEW X IN L LIST (CDRLIST X))))
))
DEFINE ((
(COPY (LAMBDA (X)
(COND
((ATOM X) X)
(T (CONS (COPY (CAR X)) (COPY (CDR X)))))))
))
DEFINE ((
(NTH (LAMBDA (L J)
(IF (EQUAL J 1) THEN L
ELSEIF (GREATERP J (LENGTH L))
THEN (PRINT(LIST @ ARGUMENT J @(TO HIGH FOR NTH OF)L))
NIL
ELSE (FOR NEW I := (2 J) PROG2 (SETQ L (CDR L))))))
))
COMMENT (***** ADDITIONAL FUNCTIONS *****)
DEFINE ((
(SINGLERINGS (LAMBDA (N)
(LIST (SINGLERING N))))
))
DEFINE ((
(INSERTMARKERS (LAMBDA (STRUC CLL L)
(PROG NIL
(FOR NEW CL IN CLL AS NEW NLL IN L FOR NEW PAIR IN CL
AS NEW NL IN NLL FOR NEW N IN NL
DO (REPLACE
(ATOMTYPE (MARKERS (FINDCTE N STRUC)))
(CAR PAIR)))
(RETURN STRUC))))
))
DEFINE ((
(DELETE (LAMBDA (I L)
(COND
((NULL L) NIL)
((EQUAL (CAR L) I) (CDR L))
(T (CONS (CAR L) (DELETE I (CDR L)))))))
))
GSET (LASTNODE 0)
TRACE ((TRIVGRAPH SINGLERING CHORDLENGTH))
- (GSET @ CATALOG-LIST (MAKECAT TRIVALENTCODES))
UNTRACE ((TRIVGRAPH SINGLERING CHORDLENGTH))
DEFINE ((
(EVALARGS (LAMBDA (ARGTYPE S)
(LIST S)))
))
DEFINE ((
(TRY? (LAMBDA (S)
T))
))
DEFINE ((
(PRINRAD (LAMBDA (L)
(PROG (N)
(PRINT L)
(SETQ N (NUMNODES L))
(PRINRAD0 N)
(PRINRAD1 NIL (FOR NEW I := (N 1 -1) XLIST I) L)
(PRINRADOFF L))))
))
DEFINE ((
(NUMNODES (LAMBDA (RAD)
(PLUS
(FOR NEW R IN (ATTACHEDRADS RAD)
PLUS (TIMES (CDR R) (NUMNODES (CAR R))))
(IF (NULL (CENTER RAD)) THEN 0
ELSEIF (ATOM (CENTER RAD)) THEN 1
ELSEIF (NOT (STRUCTURE? (RADSTRUC (CENTER RAD))))
THEN 1
ELSE (LENGTH (NODES (RADSTRUC (CENTER RAD))))))))
))
DEFINE ((
(CLEXPAND (LAMBDA (CL)
(FOR NEW PR IN CL FOR NEW I := (1 (CDR PR))
LIST (CAR PR))))
))
DEFINE ((
(PRINRAD1 (LAMBDA (EFF AA RAD)
(PROG (CENT ATTACHED J X TTABLE)
(SETQ CENT (CENTER RAD))
(SETQ ATTACHED (CLEXPAND (ATTACHEDRADS RAD)))
(RETURN (IF (NOT CENT)
THEN (PRINRAD1
(CADR AA)
(CONS
(CAR AA)
(PRINRAD1 (CAR AA) (CDR AA) (CAR ATTACHED)))
(CADR ATTACHED))
ELSEIF (OR
(ATOM CENT)
(NOT (EQ (ID (RADSTRUC CENT)) @ STRUC)))
THEN (SETQ X (CDR AA))
(FOR NEW R IN ATTACHED
DO
(SETQ J (CONS (CAR X) J))
(SETQ X (PRINRAD1 (CAR AA) X R)))
(PRINENTRY
(CAR AA)
CENT
(IF EFF THEN (CONS EFF J) ELSE J))
X
ELSE (SETQ X
(IF (NOT EFF) THEN AA
ELSE (SETQ TTABLE
(LIST (LIST
(AFFLINK CENT)
(CAR AA)
EFF)))
(CDR AA)))
(FOR NEW N IN (NODES (RADSTRUC CENT))
WHEN
(NOT (EQUAL N (AFFLINK CENT)))
DO (SETQ TTABLE (CONS (LIST N (CAR X)) TTABLE))
(SETQ X (CDR X)))
(FOR NEW NLIST IN (CUFFLINKS CENT)
FOR NEW C IN NLIST
AS NEW CT IS (ASSOC C TTABLE NIL)
DO
(APPEND1 CT (CAR X))
(SETQ X
(PRINRAD1 (CAR CT) X (CAR ATTACHED)))
(SETQ ATTACHED (CDR ATTACHED)))
(PRINCTAB (CTABLE (RADSTRUC CENT)) TTABLE)
X)))))
))
DEFINE ((
(PRINCTAB (LAMBDA (CTAB TTABLE)
(FOR NEW CT IN CTAB
AS NEW CPRIME IS (ASSOC (NODENUM CT) TTABLE NIL)
DO (PRINENTRY
(CAR CPRIME)
(ATOMTYPE MARKERS CT)
(APPEND
(CDR CPRIME)
(FOR NEW Y IN (NBRS CT) IF (NOT (EQ Y @ FV))
XLIST (CAR (ASSOC Y TTABLE NIL))))))))
))
DEFINE ((
(PRINRAD0 (LAMBDA (N)
(PROG NIL
(WRS GRAPHFILE)
(VERBOS NIL)
(OTLL 72)
(SETQ XLATN 0)
(TTAB 1)
(PRINNUM 5 N)
(TERPRI))))
))
DEFINE ((
(PRINENTRY (LAMBDA (NODE TYPE NBRS)
(PROG NIL
(TTAB 1)
(PRINNUM 3 NODE)
(XTAB 1)
(IF (ATOM TYPE) THEN (PRIN1 TYPE)
ELSE (PRIN1 @ X)
(PRIN1 (SETQ XLATN (ADD1 XLATN)))
(SETQ XLATETABLE
(CONS (CONS XLATN TYPE) XLATETABLE)))
(TTAB 9)
(FOR NEW N IN NBRS DO (PRINNUM 3 N))
(TERPRI))))
))
DEFINE ((
(PRINNUM (LAMBDA (W N)
(PROG2 (XTAB (DIFFERENCE W (WIDTH N))) (PRIN1 N))))
))
DEFINE ((
(WIDTH (LAMBDA (N)
(FOR NEW X
IN @ ((99999 6) (9999 5) (999 4) (99 3) (9 2) (0 1))
UNTIL (GREATERP N (CAR X)) PROG2 (CADR X))))
))
DEFINE ((
(PRINRADOFF (LAMBDA (L)
(PROG NIL
(TTAB 1)
(PRIN1 @ STRUCTURE=)
(PRINT L)
(FOR NEW X IN XLATETABLE
DO
(PRIN1 @ X)
(PRIN1 (CAR X))
(PRIN1 @ =)
(PRINT (CDR X)))
(TTAB 1)
(PRINT @ END*)
(WRS @ LISPOUT)
(OTLL 133)
(SETQ XLATETABLE NIL))))
))
DEFINE ((
(SETUPGRAPHICS (LAMBDA (FILE)
(PROG NIL
(SETQ GRAPHFILE FILE)
(OPEN
FILE
(QUOTE ((LRECL . 80) (BLKSIZE . 3200)))
(QUOTE OUTPUT)))))
))
COMMENT (PARTS COPIED FROM LOTUS (CAN BE DELETED LATER))
COMMENT (END OF COPIED PARTS FROM LOTUS)
RECORD (CHECKPERM (OBJ POBJ . ORIGPERM))
RECORD (NPL (REMPERMS . OKPERMS))
RECORD (CHECKVAL (LABELEDSOFAR LABELSLEFT . NPLLEFT))
RECORD (LABELING (LABELED UNLABELED . LSTRUC))
DEFINE ((
(CHECKL (LAMBDA (S SB NPL)
(IF (SETQ NPL (CHECK S SB NPL 0))
THEN (IF (REMPERMS (NPLLEFT NPL))
THEN (PRINT (LIST @ CHECKL @ ERROR: S SB NPL))
NIL
ELSE (LIST (LABELING
LABELED
=
S
UNLABELED
=
SB
LSTRUC
=
(REVERSE (OKPERMS (NPLLEFT NPL))))))
ELSE NIL)))
))
DEFINE ((
(COMB (LAMBDA (OBJ S SB NPL LABELS)
(IF (ZEROP LABELS) THEN (CHECKL S (APPEND SB OBJ) NPL)
ELSEIF (EQUAL LABELS (LENGTH OBJ))
THEN (CHECKL (APPEND OBJ S) SB NPL)
ELSEIF (GREATERP LABELS (LENGTH OBJ)) THEN NIL
ELSE (APPEND
(COMBCHECK
(CDR OBJ)
(CONS (CAR OBJ) S)
SB
NPL
(SUB1 LABELS))
(COMBCHECK
(CDR OBJ)
S
(CONS (CAR OBJ) SB)
NPL
LABELS)))))
))
DEFINE ((
(COMBCHECK (LAMBDA (OBJ S SB NPL LABELS)
(IF (SETQ NPL (CHECK S SB NPL LABELS))
THEN (COMB
(DIFF OBJ (LABELEDSOFAR NPL))
(LABELEDSOFAR NPL)
SB
(NPLLEFT NPL)
(LABELSLEFT NPL))
ELSE NIL)))
))
DEFINE ((
(DIFF (LAMBDA (L1 L2)
(FOR NEW X IN L1 WHEN
(NOT (MEMBER X L2))
XLIST X)))
))
DEFINE ((
(CHECK (LAMBDA (S SB NPL LABELS)
(PROG (NEWNPL OBJ POBJ OK)
(SETQ OK (OKPERMS NPL))
(SETQ NPL (REMPERMS NPL))
L1 (IF (NULL NPL)
THEN (RETURN (CHECKVAL
LABELEDSOFAR
=
S
NPLLEFT
=
(NPL OKPERMS = OK REMPERMS = NEWNPL)
LABELSLEFT
=
LABELS)))
(SETQ OBJ (OBJ (CAR NPL)))
(SETQ POBJ (POBJ (CAR NPL)))
L3 (IF (NULL OBJ) THEN (GO L8)
ELSEIF (MEMBER (CAR OBJ) S) THEN (GO L4)
ELSEIF (MEMBER (CAR OBJ) SB) THEN (GO L5))
L6 (SETQ NEWNPL
(CONS
(CHECKPERM FROM (CAR NPL) OBJ = OBJ POBJ = POBJ)
NEWNPL))
L2 (SETQ NPL (CDR NPL))
(GO L1)
L9 (SETQ NEWNPL NIL)
L8 (SETQ OK (CONS (ORIGPERM (CAR NPL)) OK))
(GO L2)
L4 (IF (MEMBER (CAR POBJ) S) THEN (GO L7)
ELSEIF (MEMBER (CAR POBJ) SB) THEN (RETURN NIL)
ELSEIF (MINUSP (SETQ LABELS (SUB1 LABELS)))
THEN (RETURN NIL))
(SETQ S (CONS (CAR POBJ) S))
(SETQ NPL (APPEND NEWNPL NPL))
(IF (NULL (CDR OBJ)) THEN (GO L9))
(SETQ NEWNPL
(LIST (CHECKPERM
FROM
(CAR NPL)
OBJ
=
(CDR OBJ)
POBJ
=
(CDR POBJ))))
(GO L2)
L7 (SETQ OBJ (CDR OBJ))
(SETQ POBJ (CDR POBJ))
(GO L3)
L5 (IF (MEMBER (CAR POBJ) S) THEN (GO L2)
ELSEIF (MEMBER (CAR POBJ) SB) THEN (GO L7))
(GO L6))))
))
DEFINE ((
(LLABEL (LAMBDA (OBJECTS LABELS STRUC)
(IF (NULL LABELS) THEN (LIST (LABELING LSTRUC = STRUC))
ELSE (FOR NEW L1
IN (LABELM (CAR OBJECTS) (CAR LABELS) STRUC)
FOR NEW L2
IN (LLABEL
(CDR OBJECTS)
(CDR LABELS)
(LSTRUC L1))
XLIST (LABELING
FROM
L2
LABELED
=
(CONS (LABELED L1) **))))))
))
DEFINE ((
(LABELM (LAMBDA (OBJECTS LABELS STRUC)
(IF (NULL LABELS)
THEN (LIST (LABELING UNLABELED = OBJECTS LSTRUC = STRUC))
ELSE (FOR NEW L1 IN (LABEL1 OBJECTS (CAR LABELS) STRUC)
FOR NEW L2
IN (LABELM
(UNLABELED L1)
(CDR LABELS)
(LSTRUC L1))
XLIST (LABELING
FROM
L2
LABELED
=
(CONS (LABELED L1) **))))))
))
DEFINE ((
(LABEL1 (LAMBDA (OBJECTS LABELS STRUC)
(PROG (SZ SZC)
(RETURN (IF (ZEROP LABELS)
THEN (LIST (LABELING
UNLABELED
=
OBJECTS
LSTRUC
=
STRUC))
ELSEIF (EQUAL LABELS (SETQ SZ (SIZE OBJECTS)))
THEN (LIST (LABELING
LABELED
=
OBJECTS
LSTRUC
=
STRUC))
ELSEIF (GREATERP LABELS SZ) THEN NIL
ELSEIF (NULL (CDR (SETQ OBJECTS
(CLASSES OBJECTS STRUC))))
THEN (LABEL1C (CAR OBJECTS) LABELS STRUC)
ELSE (LABEL1L OBJECTS LABELS STRUC))))))
))
DEFINE ((
(LABEL1L (LAMBDA (OBJL LABELS STRUC)
(IF (NULL OBJL)
THEN (IF (ZEROP LABELS)
THEN (LIST (LABELING LSTRUC = STRUC))
ELSE NIL)
ELSEIF (ZEROP LABELS)
THEN (LIST (LABELING
LSTRUC
=
STRUC
UNLABELED
=
(PROG (R)
(FOR NEW O IN OBJL
DO (SETQ R (COMBINE O R)))
(RETURN R))))
ELSE (PROG (SZ SZC)
(SETQ SZ
(PLUS
(SETQ SZC (SIZE (CAR OBJL)))
(FOR NEW O IN (CDR OBJL) PLUS (SIZE O))))
(RETURN (FOR NEW I
:= ((MAX
0
(DIFFERENCE LABELS (DIFFERENCE SZ SZC)))
(MIN LABELS SZC))
FOR NEW L1 IN (LABEL1C (CAR OBJL) I STRUC)
FOR NEW L2
IN (LABEL1L
(CDR OBJL)
(DIFFERENCE LABELS I)
(LSTRUC L1))
XLIST (LABELING
FROM
L2
LABELED
=
(COMBINE (LABELED L1) **)
UNLABELED
=
(COMBINE (UNLABELED L1) **))))))))
))
DEFINE ((
(COMB1 (LAMBDA (OBJ LAB UNL PERMS LABELS)
(IF (ZEROP LABELS)
THEN (LIST (LABELING
LABELED
=
LAB
UNLABELED
=
UNL
LSTRUC
=
PERMS))
ELSEIF (EQUAL LABELS (LENGTH OBJ))
THEN (LIST (LABELING
LABELED
=
(APPEND OBJ LAB)
UNLABELED
=
UNL
LSTRUC
=
PERMS))
ELSE (NCONC
(COMB1
(CDR OBJ)
(CONS (CAR OBJ) LAB)
UNL
PERMS
(SUB1 LABELS))
(COMB1
(CDR OBJ)
LAB
(CONS (CAR OBJ) UNL)
PERMS
LABELS)))))
))
DEFINE ((
(FIXUPGROUP (LAMBDA (STRUC)
(REPLACE
(GROUP STRUC)
(FINDNEWGROUP
STRUC
(CLASSIFYNODES
(PROG (X)
(SETQ X (NODES STRUC))
(FOR NEW NL IN (CAR (GROUP STRUC))
DO (SETQ X (DIFF X NL)))
(RETURN X))
STRUC)))))
))
DEFINE ((
(FINDNEWGROUP (LAMBDA (STRUC NEWORBITS)
(PROG (NEWOBJ)
(SETQ NEWOBJ
(FOR NEW ORB IN NEWORBITS
XLIST FIRST (CAR (GROUP STRUC))
(REVERSE ORB)))
(RETURN (CONS
NEWOBJ
(FOR NEW P IN (FINDNEWGROUP1 STRUC NEWORBITS)
WHEN
(NOT (EQUAL NEWOBJ (CDR P)))
XLIST (CDR P)))))))
))
DEFINE ((
(FINDNEWGROUP1 (LAMBDA (STRUC NEWORBITS)
(FOR NEW P IN (GROUP STRUC)
NCONC FIRST NIL
(FINDPERMS
(CAR NEWORBITS)
NEWORBITS
(CONS NIL P)
(CONS NIL (CAR (GROUP STRUC)))
STRUC))))
))
DEFINE ((
(FINDPERMS (LAMBDA (NODES CLASSES IMS MAPPED STRUC)
(IF (NULL CLASSES) THEN (LIST IMS)
ELSEIF (NULL NODES)
THEN (FINDPERMS
(CADR CLASSES)
(CDR CLASSES)
(CONS NIL IMS)
(CONS NIL MAPPED)
STRUC)
ELSE (FOR NEW Y
IN (POSSIMS
(CAR NODES)
(CAR CLASSES)
IMS
MAPPED
STRUC)
NCONC FIRST NIL
(FINDPERMS
(CDR NODES)
CLASSES
(CONS (CONS Y (CAR IMS)) (CDR IMS))
(CONS
(CONS (CAR NODES) (CAR MAPPED))
(CDR MAPPED))
STRUC)))))
))
DEFINE ((
(POSSIMS (LAMBDA (X CLASS IMS MAPPED STRUC)
(FOR NEW Y IN CLASS
WHEN
(NOT (MEMBER Y (CAR IMS)))
WHEN (FOR NEW ML IN MAPPED AS NEW IL IN IMS
FOR NEW M IN ML AS NEW I IN IL
AND (EQUAL
(CONNECTIVITY Y I STRUC)
(CONNECTIVITY X M STRUC)))
XLIST Y)))
))
DEFINE ((
(CONNECTIVITY (LAMBDA (X Y STRUC)
(FOR NEW Z IN (NBRS (FINDCTE X STRUC))
WHEN
(EQUAL Z Y)
PLUS 1)))
))
DEFINE ((
(GROUPCOUNT (LAMBDA (L)
(PROG NIL
(SETQ L (GROUPBY (QUOTE CDR) (CLCREATE L)))
(RETURN (FOR NEW I
:= ((FOR NEW X IN L MAX (CAR X)) 1 -1)
XLIST (CARLIST (ASSOC I L NIL)))))))
))
DEFINE ((
(FOUND? (LAMBDA (NODE GROUP)
(FOR NEW NL IN (CAR GROUP) AS NEW N := (1 9999999)
DO (IF (MEMBER NODE NL) THEN (RETURN (CONS N NL))))))
))
DEFINE ((
(FINDGROUPEDGES (LAMBDA (EDGES STRUC)
(PROG (G)
(IF (NOT (FOR NEW EDGE IN EDGES
AND (AND
(FOUND? (NODE1 EDGE) (GROUP STRUC))
(FOUND? (NODE2 EDGE) (GROUP STRUC)))))
THEN (FIXUPGROUP STRUC)
ELSE NIL)
(SETQ G (GROUP STRUC))
(RETURN (NPL
OKPERMS
=
(LIST (CAR G))
REMPERMS
=
(FOR NEW P IN (CDR G)
XLIST (CHECKPERM
ORIGPERM
=
P
OBJ
=
EDGES
POBJ
=
(FOR NEW EDGE IN EDGES
LIST (ORDPAIR
(IMAGE (NODE1 EDGE) (CAR G) P)
(IMAGE (NODE2 EDGE) (CAR G) P))))))))))
))
DEFINE ((
(IMAGE (LAMBDA (NODE MAPPED IMAGES)
(FOR NEW ML IN MAPPED AS NEW IL IN IMAGES FOR NEW M IN ML
AS NEW I IN IL WHEN
(EQUAL NODE M)
DO (RETURN I))))
))
DEFINE ((
(FINDGROUPNODES (LAMBDA (OBJECTS STRUC)
(PROG (N FOUND)
L1 (SETQ FOUND (FOUND? (CAR OBJECTS) (GROUP STRUC)))
(IF (NOT FOUND) THEN (FIXUPGROUP STRUC)
ELSE (RETURN (NPL
OKPERMS
=
(LIST (CAR (GROUP STRUC)))
REMPERMS
=
(FOR NEW P IN (CDR (GROUP STRUC))
XLIST (CHECKPERM
ORIGPERM
=
P
OBJ
=
(CDR FOUND)
POBJ
=
(CAR (NTH P (CAR FOUND))))))))
(GO L1))))
))
RECORD (NODETYPE (IDNODE . NODENUMS))
DEFAULT (NODETYPE (IDNODE NODES))
MACRO ((
(NODES? (LAMBDA (X)
(EQ (IDNODE X) @ NODES)))
))
RECORD (MULTTYPE (IDMULT MULT . UNMULTED))
DEFAULT (MULTTYPE (IDMULT MULT))
MACRO ((
(MULTTYPE? (LAMBDA (X)
(EQ (IDMULT X) @ MULT)))
))
RECORD (EDGETYPE (IDEGES . NODEPRS))
DEFAULT (EDGETYPE (IDEGES EDGES))
MACRO ((
(EDGES? (LAMBDA (X)
(EQ (IDEGES X) @ EDGES)))
))
RECORD (COMBINATION (IDCOMB OBJ1 . OBJ2))
DEFAULT (COMBINATION (IDCOMB BOTH))
MACRO ((
(COMBINATION? (LAMBDA (X)
(EQ (IDCOMB X) @ BOTH)))
))
RECORD (UNCLASSED (IDUNCLASSED . OBJECTS))
DEFAULT (UNCLASSED (IDUNCLASSED ?))
MACRO ((
(UNCLASSED? (LAMBDA (X)
(EQ (IDUNCLASSED X) @ ?)))
))
RECORD (OTHERTYPE (OTHID OTHOBJECTS))
DEFAULT (OTHERTYPE (OTHID SOMETHING←ELSE))
DEFINE ((
(SIZE (LAMBDA (OBJECTS)
(IF (MULTTYPE? OBJECTS)
THEN (TIMES (MULT OBJECTS) (SIZE (UNMULTED OBJECTS)))
ELSEIF (COMBINATION? OBJECTS)
THEN (PLUS (SIZE (OBJ1 OBJECTS)) (SIZE (OBJ2 OBJECTS)))
ELSEIF (OR
(NODES? OBJECTS)
(EDGES? OBJECTS)
(UNCLASSED? OBJECTS)) THEN (LENGTH (CDR OBJECTS))
ELSE (PRINT (CONS OBJECTS @(BAD ARG TO SIZE))
0)))
))
DEFINE ((
(COMBINE (LAMBDA (O1 O2)
(IF (NOT O1) THEN O2
ELSEIF (NOT O2) THEN O1
ELSE (COMBINATION OBJ1 = O1 OBJ2 = O2))))
))
DEFINE ((
(CLASSES (LAMBDA (OBJECTS STRUC)
(IF (COMBINATION? OBJECTS)
THEN (NCONC
(CLASSES (OBJ1 OBJECTS))
(CLASSES (OBJ2 OBJECTS)))
ELSEIF (NOT (UNCLASSED? OBJECTS)) THEN (LIST OBJECTS)
ELSE (CLASSES2 (OBJECTS OBJECTS) STRUC))))
))
DEFINE ((
(CLASSES2 (LAMBDA (OBJECTS STRUC)
(PROG NIL
(SETQ OBJECTS (GROUPCOUNT OBJECTS))
(COMMENT FIRST CLASSIFY BY NUMBER OF OCCURANCES)
(RETURN (FOR NEW O IN (CDR OBJECTS)
AS NEW M := (2 999999)
FOR NEW O2 IN (CLASSIFY3 O STRUC)
XLIST FIRST (CLASSIFY3 (CAR OBJECTS) STRUC)
(MAKEMULT M O2))))))
))
MACRO ((
(CONSTO (LAMBDA (VAR VAL)
(SETQ VAR (CONS VAL VAR))))
))
DEFINE ((
(CLASSIFY3 (LAMBDA (OBJECTS STRUC)
(PROG (N E OTH)
(COMMENT CLASSIFY BY NODETYPE OR EDGETYPE FIRST)
(FOR NEW X IN OBJECTS
DO (IF (NUMBERP X) THEN (CONSTO N X)
ELSEIF (AND (NUMBERP (CAR X)) (NUMBERP (CDR X)))
THEN (CONSTO E X)
ELSE (CONSTO OTH X)))
(RETURN (* NCONC
(MAPCAR (CLASSIFYNODES N STRUC) @ MAKENODES)
(MAPCAR (CLASSIFYEDGES E STRUC) @ MAKEEDGES)
(IF OTH THEN (LIST (OTHERTYPE OTHOBJECTS = OTH))
ELSE NIL))))))
))
SPECIAL ((SSTRUC))
DEFINE ((
(CLASSIFYNODES (LAMBDA (NODES SSTRUC)
(CDRLIST (GROUPBY (FUNCTION NODEMARK) NODES))))
))
DEFINE ((
(CLASSIFYEDGES (LAMBDA (EDGES SSTRUC)
(CDRLIST (GROUPBY (FUNCTION EDGEMARK) EDGES))))
))
DEFINE ((
(NODEMARK (LAMBDA (NODE)
(PROG2
(SETQ NODE (FINDCTE NODE SSTRUC))
(CONS (NODEVALENCE NODE) (MARKERS NODE)))))
))
DEFINE ((
(ORDPAIR (LAMBDA (X1 X2)
(IF (LEQ X1 X2) THEN (CONS X1 X2) ELSE (CONS X2 X1))))
))
DEFINE ((
(EDGEMARK (LAMBDA (EDGE)
(ORDPAIR (NODEMARK (NODE1 EDGE)) (NODEMARK (NODE2 EDGE)))))
))
UNSPECIAL ((SSTRUC))
DEFINE ((
(LABEL1C (LAMBDA (OBJECTS LABELS STRUC)
(IF (ZEROP LABELS)
THEN (LIST (LABELING UNLABELED = OBJECTS LSTRUC = STRUC))
ELSEIF (EQUAL LABELS (SIZE OBJECTS))
THEN (LIST (LABELING LABELED = OBJECTS LSTRUC = STRUC))
ELSEIF (NODES? OBJECTS)
THEN (LABELN (NODENUMS OBJECTS) LABELS STRUC)
ELSEIF (EDGES? OBJECTS)
THEN (LABELE (NODEPRS OBJECTS) LABELS STRUC)
ELSEIF (MULTTYPE? OBJECTS)
THEN (LABELMULT
(MULT OBJECTS)
(UNMULTED OBJECTS)
LABELS
STRUC)
ELSE (LABELUNDEFINEDSTRUC OBJECTS LABELS STRUC))))
))
DEFINE ((
(MAKEMULT (LAMBDA (M OBJ)
(IF (ZEROP M) THEN NIL
ELSEIF (EQUAL M 1) THEN OBJ
ELSE (MULTTYPE MULT = M UNMULTED = OBJ))))
))
DEFINE ((
(MAKENODES (LAMBDA (NODES)
(IF (NOT NODES) THEN NIL ELSE (NODETYPE NODENUMS = NODES))))
))
DEFINE ((
(MAKEEDGES (LAMBDA (EDGES)
(IF (NOT EDGES) THEN NIL ELSE (EDGETYPE NODEPRS = EDGES))))
))
DEFINE ((
(LABELMULT (LAMBDA (MULTS UNMULTED LABELS STRUC)
(FOR NEW P
IN (NUMPARTITIONS LABELS (SIZE UNMULTED) 0 MULTS)
AS NEW CLP IS (CLCREATE P)
FOR NEW L IN (LABELM UNMULTED (CDRLIST CLP) STRUC)
XLIST (LABELING
FROM
L
LABELED
=
(FOR NEW X IN ** AS NEW PR IN CLP
COMBINE FIRST NIL
(MAKEMULT (CAR PR) X))
UNLABELED
=
(FOR NEW X IN (LABELED L) AS NEW PR IN CLP
COMBINE FIRST NIL
(MAKEMULT (DIFFERENCE MULTS (CAR PR)) X)))))
)
))
DEFINE ((
(LABEL0A (LAMBDA (OBJECTS STRUC NPL LABELS MAKEFN)
(FOR NEW L
IN (IF (NOT (REMPERMS NPL))
THEN (COMB1 OBJECTS NIL NIL (OKPERMS NPL) LABELS)
ELSE (COMB
OBJECTS
NIL
(DIFF (OBJ (CAR (REMPERMS NPL))) OBJECTS)
NPL
LABELS))
XLIST (LABELING
FROM
L
LABELED
=
(MAKEFN **)
UNLABELED
=
(MAKEFN (DIFF OBJECTS (LABELED L)))
LSTRUC
=
(STRUCTURE FROM STRUC GROUP = (LSTRUC L))))))
))
DEFINE ((
(LABELN (LAMBDA (NODENUMS LABELS STRUC)
(LABEL0A
NODENUMS
STRUC
(FINDGROUPNODES NODENUMS STRUC)
LABELS
(FUNCTION MAKENODES))))
))
DEFINE ((
(LABELE (LAMBDA (EDGES LABELS STRUC)
(LABEL0A
EDGES
STRUC
(FINDGROUPEDGES EDGES STRUC)
LABELS
(FUNCTION MAKEEDGES))))
))
DEFINE ((
(UNCLASS (LAMBDA (OBJECTS)
(IF (NOT OBJECTS) THEN NIL
ELSEIF (UNCLASSED? OBJECTS) THEN (OBJECTS OBJECTS)
ELSEIF (NODES? OBJECTS) THEN (NODENUMS OBJECTS)
ELSEIF (EDGES? OBJECTS) THEN (NODEPRS OBJECTS)
ELSEIF (MULTTYPE? OBJECTS)
THEN (FOR NEW M := (1 (MULT OBJECTS))
APPEND (UNCLASS (UNMULTED OBJECTS)))
ELSEIF (COMBINATION? OBJECTS)
THEN (APPEND
(UNCLASS (OBJ1 OBJECTS))
(UNCLASS (OBJ2 OBJECTS)))
ELSE (PRINT (CONS OBJECTS @(ERROR ARG TO UNCLASS))
NIL)))
))
DEFINE ((
(LUNCLASS (LAMBDA (LOBJ)
(MAPCAR LOBJ (FUNCTION UNCLASS))))
))
DEFINE ((
(LLUNCLASS (LAMBDA (LLOBJ)
(MAPCAR LLOBJ (FUNCTION LUNCLASS))))
))
COMMENT (FUNCTIONS FROM LOTUS WHICH NEED TO BE CHANGED)
DEFINE ((
(PERMRADS (LAMBDA (CENT CLRADS FLAG)
(PROG2
(SETQ CLRADS (CLCREATE CLRADS))
(IF (ATOM CENT)
THEN (LIST (RADICAL
CENTER
=
CENT
ATTACHEDRADS
=
CLRADS))
ELSEIF (STRUCFORM? CENT)
THEN (LIST (RADICAL
CENTER
=
(MAKECENTER RADSTRUC = CENT)
ATTACHEDRADS
=
CLRADS))
ELSE (FOR NEW L
IN (LABELFV
CENT
((LAMBDA (X)
(IF FLAG THEN (CONS 1 X) ELSE X))
(CDRLIST CLRADS)))
XLIST (RADICAL
CENTER
=
(MAKECENTER
AFFLINK
=
(IF FLAG THEN (CAAR (LABELED L))
ELSE NIL)
RADSTRUC
=
(LSTRUC L)
CUFFLINKS
=
(IF FLAG THEN (CDR (LABELED L))
ELSE (LABELED L)))
ATTACHEDRADS
=
CLRADS))))))
))
DEFINE ((
(LABELEDGES (LAMBDA (STRUC LABELS)
(FOR NEW L
IN (LABELM
(UNCLASSED
OBJECTS
=
(FOR NEW CT IN (CTABLE STRUC)
FOR NEW N IN (NBRS CT)
WHEN
(LEQ (NODENUM CT) N)
XLIST (CONS (NODENUM CT) N)))
LABELS
STRUC)
XLIST (LABELING FROM L LABELED = (LUNCLASS **)))))
))
DEFINE ((
(LABELFV (LAMBDA (STRUC LABELS)
(FOR NEW L
IN (LABELM
(UNCLASSED OBJECTS = (COLLECTFV STRUC))
LABELS
STRUC)
XLIST (LABELING FROM L LABELED = (LUNCLASS **)))))
))
DEFINE ((
(STRUCTURESWITHATOMS (LAMBDA (CLL STRUC)
(FOR NEW L IN (LLABELNODES STRUC (LCDRLIST CLL))
XLIST (INSERTMARKERS
(COPYSTRUC (LSTRUC L))
CLL
(LABELED L)))))
))
DEFINE ((
(ATTACHFVS (LAMBDA (FVP STRUC)
(FOR NEW L IN (LLABELNODES STRUC FVP)
XLIST (PUTFVS (COPYSTRUC (LSTRUC L)) (LABELED L)))))
))
DEFINE ((
(ATTACHBIVALENTS (LAMBDA (PART STRUC)
(FOR NEW L IN (LABELEDGES STRUC (CDRLIST PART))
XLIST (PUTBIVS
(COPYSTRUC (LSTRUC L))
(CARLIST PART)
(LABELED L)))))
))
DEFINE ((
(LLABELNODES (LAMBDA (STRUC LLABELS)
(FOR NEW L
IN (LLABEL
(MAPCAR (LISTBYVALENCE STRUC) @ MAKEUNCLASSED)
LLABELS
STRUC)
XLIST (LABELING FROM L LABELED = (LLUNCLASS **)))))
))
DEFINE ((
(MAKEUNCLASSED (LAMBDA (X)
(IF (NOT X) THEN NIL ELSE (UNCLASSED OBJECTS = X))))
))
ADVISE (((ATTACHFVS BEFORE (PROG2 (SETQ !VALUE (STRUCFORM FORM =(LIST
@ ATTACHFVS ARG1 ARG2))) (IF (STRUCFORM? ARG2) THEN (RETURN (
EVALARGS @ (NIL FORM) !VALUE)) ELSEIF (NOT (TRY? !VALUE)) THEN (
RETURN (LIST !VALUE)) ELSE NIL)))))
ADVISE (((STRUCTURESWITHATOMS BEFORE (PROG2 (SETQ !VALUE (STRUCFORM
FORM = (LIST @ STRUCTURESWITHATOMS ARG1 ARG2))) (IF (STRUCFORM?
ARG2) THEN (RETURN (EVALARGS @ (NIL FORM) !VALUE)) ELSEIF (NOT (
TRY? !VALUE)) THEN (RETURN (LIST !VALUE)) ELSE NIL)))))
COMMENT (MORE CATALOG ENTRIES PUT IN HERE)
(LIST
(GSET
(QUOTE T03)
(STRUCTURE
NODES
=
@ (1 2 3)
LASTNODE#
=
3
UGRAPH
=
@ T03
CTABLE
=
(LIST
(CTENTRY NODENUM = 1 NBRS = @ (2 2 3 3))
(CTENTRY NODENUM = 2 NBRS = @ (3 3 1 1))
(CTENTRY NODENUM = 3 NBRS = @ (1 1 2 2)))))
(GSET
(QUOTE T21)
(STRUCTURE
NODES
=
@ (1 2 3)
LASTNODE#
=
3
UGRAPH
=
@ T21
CTABLE
=
(LIST
(CTENTRY NODENUM = 1 NBRS = @ (2 2 3 3))
(CTENTRY NODENUM = 2 NBRS = @ (1 1 3))
(CTENTRY NODENUM = 3 NBRS = @ (1 1 2)))))
(GSET
(QUOTE T22)
(FOR NEW X IN (CATALOG3 @ (4))
FOR NEW Y IN (LABEL1 @ (NODES 1 2 3 4) 2 X)
AS NEW Z IS (COPYSTRUC (LSTRUC Y))
XLIST
(CONNECT
(FINDCTE (CAR (NODENUMS (LABELED Y))) Z)
(FINDCTE (CADR (NODENUMS (LABELED Y))) Z))
Z))
(GSET
(QUOTE T41)
(LIST
(STRUCTURE
LASTNODE#
=
5
UGRAPH
@ T41KITE
CTABLE
=
(LIST
(CTENTRY NODENUM = 1 NBRS = @ (2 3 4 5))
(CTENTRY NODENUM = 2 NBRS = @ (1 3 5))
(CTENTRY NODENUM = 3 NBRS = @ (1 2 4))
(CTENTRY NODENUM = 4 NBRS = @ (1 3 5))
(CTENTRY NODENUM = 5 NBRS = @ (1 2 4))))
(STRUCTURE
LASTNODE#
=
5
UGRAPH
@ T41SCOOP
CTABLE
=
(LIST
(CTENTRY NODENUM = 1 NBRS = @ (2 2 4 5))
(CTENTRY NODENUM = 2 NBRS = @ (1 1 3))
(CTENTRY NODENUM = 3 NBRS = @ (2 4 5))
(CTENTRY NODENUM = 4 NBRS = @ (1 3 5))
(CTENTRY NODENUM = 5 NBRS = @ (1 3 4))))
(STRUCTURE
LASTNODE#
=
5
UGRAPH
@ T41FAN
CTABLE
=
(LIST
(CTENTRY NODENUM = 1 NBRS = @ (2 4 5 5))
(CTENTRY NODENUM = 2 NBRS = @ (1 3 3))
(CTENTRY NODENUM = 3 NBRS = @ (2 2 4))
(CTENTRY NODENUM = 4 NBRS = @ (1 3 5))
(CTENTRY NODENUM = 5 NBRS = @ (1 1 4))))
(STRUCTURE
LASTNODE#
=
5
UGRAPH
@ T41RING
CTABLE
=
(LIST
(CTENTRY NODENUM = 1 NBRS = @ (2 2 5 5))
(CTENTRY NODENUM = 2 NBRS = @ (1 1 3))
(CTENTRY NODENUM = 3 NBRS = @ (2 4 4))
(CTENTRY NODENUM = 4 NBRS = @ (3 3 5))
(CTENTRY NODENUM = 5 NBRS = @ (1 1 4))))
(STRUCTURE
LASTNODE#
=
5
UGRAPH
@ T41HOURGLASS
CTABLE
=
(LIST
(CTENTRY NODENUM = 1 NBRS = @ (2 3 4 5))
(CTENTRY NODENUM = 2 NBRS = @ (1 3 3))
(CTENTRY NODENUM = 3 NBRS = @ (1 2 2))
(CTENTRY NODENUM = 4 NBRS = @ (1 5 5))
(CTENTRY NODENUM = 5 NBRS = @ (1 4 4))))))
))))))
ADVISE (((CATALOG3 BEFORE (IF (EQUAL ARG1 @ (0 3)) THEN (RETURN (LIST
T03)) ELSEIF (EQUAL ARG1 @ (2 2)) THEN (RETURN T22) ELSEIF (EQUAL
ARG1 @ (4 1)) THEN (RETURN T41) ELSEIF (EQUAL ARG1 @ (2 1)) THEN (
RETURN (LIST T21))))))
DEFINE ((
(TD (LAMBDA (VL J)
(IF (NOT VL) THEN 0
ELSE (PLUS (TIMES J (CAR VL)) (TD (CDR VL) (ADD1 J))))))
))
DEFINE ((
(M2/2 (LAMBDA (N)
(SUB1 (QUOTIENT N 2))))
))
DEFINE ((
(MAXREST (LAMBDA (VL J)
(FOR NEW X IN (CDR VL) AS NEW K := ((ADD1 J) 9999999)
PLUS (TIMES X (M2/2 K)))))
))
DEFINE ((
(LOOPPARTITIONS1 (LAMBDA (P VL J)
(IF (NOT VL) THEN (LIST NIL)
ELSE (FOR NEW PJ
:= ((MAX 0 (DIFFERENCE P (MAXREST VL J)))
(MIN P (TIMES (M2/2 J) (CAR VL))))
AS NEW RESTL
IS (LOOPPARTITIONS1
(DIFFERENCE P PJ)
(CDR VL)
(ADD1 J))
FOR NEW THISPART
IN (FVPART1 PJ (CAR VL) (M2/2 J))
FOR NEW RESTPART IN RESTL
XLIST (CONS THISPART RESTPART)))))
))
DEFINE ((
(JLIST (LAMBDA (LL N)
(IF (NOT LL) THEN NIL
ELSEIF (NOT (CDR LL)) THEN (LIST (CAR (NTH (CAR LL) N)))
ELSE (CONS
(CAR (NTH (CAR LL) N))
(JLIST (CDDR LL) (ADD1 N))))))
))
DEFINE ((
(LPROWS (LAMBDA (LPP VL)
(PROG2
(SETQ LPP (CONS NIL LPP))
(FOR NEW S := (4 999999)
AS NEW V
IN (* CONS
(CAR VL)
(FOR NEW V2 IN (CDR VL) AS NEW PL IN LPP
LIST (DIFFERENCE V2 (*PLUS PL))))
AS LPP IS (IF LPP THEN (CDR LPP) ELSE NIL)
LIST (CONS V (JLIST LPP (M2/2 S)))))))
))
DEFINE ((
(LOOPPARTITIONS (LAMBDA (P VL)
(FOR NEW LPP IN (LOOPPARTITIONS1 P (CDDR VL) 4)
AS NEW ROWS IS (LPROWS LPP VL)
FOR NEW K := (0 (TD (CDR VL) 3))
FOR NEW BP
IN (NUMPARTITIONS (CAR VL) (PLUS P K) 1 999999)
AS NEW CLBP IS (CLCREATE BP)
FOR NEW EL IN (CLPARTS CLBP K)
FOR NEW LPL
IN (CLPARTITIONSL
(CLDIFF CLBP EL)
(CDRLIST ROWS))
XLIST (LOOPPARTITION
LOOPVL
=
(CONS
(*PLUS (CDAR ROWS))
(MAPCAR (CDR ROWS) @ *PLUS))
EDGELABELS
=
EL
LOOPLABELS
=
LPL))))
))
DEFINE ((
(CLPARTITIONSL (LAMBDA (CL LL)
(IF (NOT LL) THEN (LIST NIL)
ELSE (FOR NEW FP IN (CLPARTS CL (*PLUS (CAR LL)))
AS NEW RPL
IS (CLPARTITIONSL (CLDIFF CL FP) (CDR LL))
FOR NEW TP IN (CLPARTLP1 FP (CAR LL) 1)
FOR NEW RP IN RPL XLIST (CONS TP RP)))))
))
DEFINE ((
(CLPARTLP1 (LAMBDA (CL ROW N)
(IF (NOT ROW) THEN (LIST NIL)
ELSEIF (ZEROP (CAR ROW))
THEN (CLPARTLP1 CL (CDR ROW) (ADD1 N))
ELSE (FOR NEW EP IN (CLPARTS CL (TIMES N (CAR ROW)))
AS NEW RPL
IS (CLPARTLP1 (CLDIFF CL EP) (CDR ROW) (ADD1 N))
FOR NEW EEP IN (CL=PARTS EP (CAR ROW) N)
FOR NEW RP IN RPL
XLIST (APPEND (CLCREATE EEP) RP)))))
))
DEFINE ((
(KLOOPEDRINGS (LAMBDA (P VL)
(IF (ZEROP P) THEN (NOLOOPEDRINGS VL)
ELSE (FOR NEW LOOPPART IN (LOOPPARTITIONS P VL)
FOR NEW STRUC IN (NOFV-RINGS (LOOPVL LOOPPART))
NCONC FIRST NIL
(ATTACHBIVS&LOOPS
(EDGELABELS LOOPPART)
(LOOPLABELS LOOPPART)
STRUC)))))
))
DEFINE ((
(ATTACHBIVS&LOOPS (LAMBDA (EL LL STRUC)
(IF (NOT EL)
THEN (FOR NEW L2 IN (LLABELNODES STRUC (LCDRLIST LL))
XLIST (PUTLOOPS
(COPYSTRUC (LSTRUC L2))
(LCARLIST LL)
(LABELED L2)))
ELSE (FOR NEW L1 IN (LABELEDGES STRUC (CDRLIST EL))
FOR NEW L2
IN (LLABELNODES (LSTRUC L1) (LCDRLIST LL))
XLIST (PUTLOOPS
(PUTBIVS
(COPYSTRUC (LSTRUC L2))
(CARLIST EL)
(LABELED L1))
(LCARLIST LL)
(LABELED L2))))))
))
DEFINE ((
(PUTLOOPS (LAMBDA (STRUC LPS LNODES)
(PROG2
(FOR NEW LOBJ IN LNODES AS NEW LLABS IN LPS
FOR NEW OBJ IN LOBJ AS NEW LAB IN LLABS
FOR NEW LPPR IN LAB FOR NEW I := (1 (CDR LPPR))
FOR NEW NODE IN OBJ
DO (SETQ STRUC (PUTBIVN STRUC NODE (CAR LPPR))))
STRUC)))
))
DEFINE ((
(PUTBIVN (LAMBDA (STRUC NODE NBIVS)
(IF (ZEROP NBIVS) THEN STRUC
ELSE (PROG (B)
(SETQ B (BIVCHAIN NBIVS))
(CONNECT
(CAR (CTABLE B))
(SETQ NODE (FINDCTE NODE (CTABLE STRUC))))
(CONNECT (CAR (LAST (CTABLE B))) NODE)
(NCONC (CTABLE STRUC) (CTABLE B))
(REPLACE (LASTNODE# STRUC) (LASTNODE# B))
(RETURN STRUC)))))
))
DEFINE ((
(PUTBIVS (LAMBDA (S L LST)
(PROG2
(FOR NEW X IN LST AS NEW N IN L FOR NEW E IN X
DO (PUTBIVE S E N))
S)))
))
DEFINE ((
(PUTBIVE (LAMBDA (S E N)
(IF (ZEROP N) THEN S
ELSE (PROG (B N1 N2)
(SETQ B (BIVCHAIN N))
(CONNECT
(CAR (CTABLE B))
(SETQ N1 (FINDCTE (CAR E) (CTABLE S))))
(CONNECT
(CAR (LAST (CTABLE B)))
(SETQ N2 (FINDCTE (CDR E) (CTABLE S))))
(DISCONNECT N1 N2)
(NCONC (CTABLE S) (CTABLE B))
(REPLACE (LASTNODE# S) (LASTNODE# B))
(RETURN S)))))
))
ADVISE (((ATTACHBIVS&LOOPS BEFORE (PROG2 (SETQ !VALUE (STRUCFORM
FORM = (LIST @ ATTACHBIVS&LOOPS ARG1 ARG2 ARG3))) (IF (STRUCFORM?
ARG3) THEN (RETURN (EVALARGS @ (NIL NIL FORM) !VALUE)) ELSEIF (NOT
(TRY? !VALUE)) THEN (RETURN (LIST !VALUE)) ELSE NIL)))))
ADVISE (((ATTACHBIVALENTS BEFORE (PROG2 (SETQ !VALUE (STRUCFORM FORM
= (LIST @ ATTACHBIVALENTS ARG1 ARG2))) (IF (STRUCFORM? ARG2) THEN (
RETURN (EVALARGS @ (NIL FORM) !VALUE)) ELSEIF (NOT (TRY? !VALUE))
THEN (RETURN (LIST !VALUE)) ELSE NIL)))))
SPECIAL ((MOLNUM STARTPRINTAT TYPECOUNT))
DEFINE(( (ISOMERS (LAMBDA(U CL) (PROG ()
(SETQ MOLNUM 1) (SETQ TYPECOUNT NIL)
(MOLECULES CL U)
(EJECT)
(FOR NEW X IN TYPECOUNT DO
(PRINC (CDR X)) (TTAB 10) (PRINT (CAR X)))
))))))))
DEFINE ((
(GENMOL (LAMBDA (CL)
(PROG (MINDEG RESULT NATOMS)
(IF (EQUAL 1 (SETQ NATOMS (CLCOUNT CL)))
THEN (PRINTSTRUCS (PERMRADS (CAAR CL) NIL NIL)) (RETURN NIL)
ELSEIF (EVENP NATOMS)
THEN (FOR NEW PART
IN (CL=PARTS CL 2 (QUOTIENT NATOMS 2))
FOR NEW RADS IN (GENRADLIST PART)
DO (SETQ RESULT
(APPEND
(PRINTSTRUCS (PERMRADS NIL RADS NIL) )
RESULT)))
(SETQ MINDEG 3)
ELSE (SETQ MINDEG 2))
(SETQ NATOMS (SUB1 NATOMS))
(FOR NEW PAIR IN CL AS NEW CENTER IS (CAR PAIR)
AS NEW NEWCL IS (CLDIFF CL (LIST (CONS CENTER 1)))
FOR NEW DEG
:= (MINDEG (MIN (VALENCE CENTER) NATOMS))
FOR NEW P
IN (CLPARTITIONSN
NEWCL
DEG
1
(QUOTIENT NATOMS 2))
FOR NEW RADS IN (GENRADLIST P)
DO (SETQ RESULT
(NCONC
(PRINTSTRUCS (PERMRADS CENTER RADS NIL) )
RESULT)))
(RETURN RESULT))))
))
DEFINE ((
(PRINTSTRUCS (LAMBDA (L)
(FOR NEW X IN L AS MOLNUM := (MOLNUM 99999)
WHEN (GREATERP (ADD1 MOLNUM) STARTPRINTAT)
DO (SETQ TYPECOUNT (CLINSERT (UGOFMOL X) TYPECOUNT))
(TTAB 5)
(PRINRAD X)
)))
))
DEFINE(((UGOFMOL (LAMBDA(MOL)(CLCREATE(UGOFRAD MOL))))))))))
DEFINE(((UGOFRAD (LAMBDA(RAD)
(FOR NEW RP IN (ATTACHEDRADS RAD)FOR NEW I := (1 (CDR RP)) APPEND
FIRST (IF (OR (ATOM (CENTER RAD))
(NOT (STRUCTURE? (RADSTRUC (CENTER RAD)))))
THEN NIL ELSE (LIST(UGRAPH(RADSTRUC(CENTER RAD)))))
(UGOFRAD (CAR RP))))))))))))
SPECIAL((LONGPRINTOUT))
GSET(LONGPRINTOUT NIL))
GSET(STARTPRINTAT 0)
DEFINE ((
(PRINRAD (LAMBDA (L)
(PROG (N)
(COND (LONGPRINTOUT (PRINT L)) (T NIL))
(SETQ N (NUMNODES L))
(PRINRAD0 N)
(PRINRAD1 NIL (FOR NEW I := (N 1 -1) XLIST I) L)
(PRINRADOFF (COND (LONGPRINTOUT L) (T MOLNUM))) )))))))))))
))
DEFINE(((PRINOB(LAMBDA()(FOR NEW X IN OBLIST WHEN(CDR X)
DO (TTAB 1)(PRIN1 X)(TTAB 25)(PRINC (CDR X)) (TERPRI))))))))))
RECLAIM NIL
OPEN (CYC SYSFILE OUTPUT)
CHKPOINT (CYC)
CLOSE (CYC)
GSET (TTLIST NIL)
DEFINE ((
(TT (LAMBDA (L)
(FOR NEW X IN L
WHEN
(NOT (MEMBER X TTLIST))
DO (TIMETOT (LIST X))
(SETQ TTLIST (CONS X TTLIST)))))
))
TRACE ((GENMOL MOLECULES SUPERATOMPARTITIONS SUPERATOMS RINGS
FVPARTITIONS RINGSKELETONS NOFV-RINGS DAISIES NOLOOPEDRINGS
BIVALENTPARTITIONS ISOMERS KLOOPEDRINGS PERMRADS ATTACHLOOPS
CATALOG STRUCWITH2NODES CATALOG3 DAISY SINGLERING BIVCHAIN
GROUPRADS COPYSTRUC FINDCTE ATTACHBIVS&LOOPS PUTLOOPS PUTBIVE
PUTBIVN PUTBIVS PUTFVN PUTFVS SINGLERINGS INSERTMARKERS EVALARGS
TRY? PRINRAD FIXUPGROUP FINDNEWGROUP FINDGROUPEDGES
FINDGROUPNODES PERMRADS LABELEDGES LABELFV STRUCTURESWITHATOMS
ATTACHFVS ATTACHBIVALENTS LLABELNODES))
TT ((CLCREATE GENMOL MOLECULES SUPERATOMPARTITIONS SUPERATOMS RINGS